The World of Computer Software/The World of Computer Software.iso/psd.zip/INSTRUM.SCM

Text File | 1992-07-10 | 18KB | 619 lines

;;;;
;;;; instrum.scm 1.17
;;;;
;;;; psd -- a portable Scheme debugger, version 1.0
;;;; Copyright (C) 1992 Pertti Kellomaki, [e-mail]

;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 1, or (at your option)
;;;; any later version.

;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.

;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;; See file COPYING in the psd distribution.

;;;;  Written by Pertti Kellomaki, [e-mail]

;;;; This file contains the actual instrumentation code.  For each
;;;; syntactic form X to be instrumented, there is a corresponding
;;;; procedure instrument-X. In addition, there are a few helpful
;;;; procedures for instrumenting expression sequences etc. The
;;;; procedures psd-car, psd-cdr etc. that are used here work just like
;;;; normal car, cdr etc., but they operate on pexps, which are sexps
;;;; with position information.

;;;
;;; Instrument source-file, writing the instrumented version to
;;; instrumented-file.
;;;

(define instrument-file

  (let ((caadr caadr) (caddr caddr) (cadr cadr) (car car) (cdr cdr)
              (close-output-port close-output-port) (cons cons)
              (eof-object? eof-object?) (eq? eq?) (error error)
              (list list) (map map) (newline newline) (not not)
              (null? null?) (open-input-file open-input-file)
              (open-output-file open-output-file) (pair? pair?)
              (reverse reverse) (write write))


    (lambda (source-file instrumented-file)

;;;
;;; Instrument an expression.
;;;

      (define (instrument-expr expr)

    (define (wrap instrumented-expr)

      (define file-name car)    ; for accessing the position info
      (define line-number cadr)
      (define column caddr)

      `(psd-debug psd-val psd-set! psd-context
              ',(pexp->sexp expr)
              ,(file-name (psd-expr-start expr))
              ,(line-number (psd-expr-start expr))
              ,(line-number (psd-expr-end expr))
              (lambda () ,instrumented-expr)))

    (cond

     ;; expressions of the form (symbol ...) that are
     ;; potential special forms
     ((and (psd-pair? expr)
           (psd-symbol? (psd-car expr)))
      (case (psd-expr-contents (psd-car expr))
        ((and) (wrap (instrument-and expr)))
        ((begin) (wrap (instrument-begin expr)))
        ((case) (wrap (instrument-case expr)))
        ((cond) (wrap (instrument-cond expr)))
        ((define) (instrument-define expr))
        ((do) (instrument-do expr))
        ((if) (wrap (instrument-if expr)))
        ((lambda) (wrap (instrument-lambda expr)))
        ((let) (wrap (instrument-let expr)))
        ((let*) (wrap (instrument-let* expr)))
        ((letrec) (wrap (instrument-letrec expr)))
        ((or) (wrap (instrument-or expr)))
        ((quasiquote) (wrap (instrument-quasiquote expr)))
        ((quote) (instrument-quote expr))
        ((set!) (wrap (instrument-set! expr)))

        ;; anything we don't recognize must be a procedure call
        (else
         (wrap (instrument-call expr)))))

     ;; list that starts with a list must be a procedure call
     ;; somewhere deep down
     ((psd-pair? expr)
      (wrap (instrument-call expr)))

     ;; ordinary atoms
     ((or (psd-symbol? expr)
          (psd-number? expr)
          (psd-string? expr)
          (psd-vector? expr)
          (psd-char? expr)
          (psd-boolean? expr)
          (psd-null? expr))
      (wrap (pexp->sexp expr)))

     (else
      (error "Can not handle " expr))))


;;;
;;; A wrapper that has visibility to all the given symbols is needed
;;; in a few places.
;;;

      (define (access-wrapper exprs variables)
    `(let ,(build-val-set-definitions variables)
       ,@exprs))

;;;
;;; Build definitions for psd-val and psd-set!
;;; Beware that variables can be a list of variables, a single
;;; variable or a list of the form (a b . c)
;;;
;;; The definitions are of the form
;;;
;;;  ((psd-val (lambda (...) ...))
;;;   (psd-set! (lambda (...) ...)))
;;;
;;; suitable for inclusion in a let form.
;;;

      (define (build-set-definition variables)
    (let loop ((variables variables)
           (set-body '()))
      (cond ((null? variables)
         `(lambda (psd-temp psd-temp2)
            (case psd-temp
              ,@set-body
              (else (psd-set! psd-temp psd-temp2)))))
        (else
         (loop (cdr variables)
               (cons `((,(car variables)) (set! ,(car variables) psd-temp2))
                 set-body))))))

      (define (build-val-definition variables)
    (let loop ((variables variables)
           (val-body '()))
      (cond ((null? variables)
         `(lambda (psd-temp)
            (case psd-temp
              ,@val-body
              (else (psd-val psd-temp)))))
        (else
         (loop (cdr variables)
               (cons `((,(car variables)) ,(car variables))
                 val-body))))))

      (define (build-val-set-definitions variables)

    ;; build a proper list out of the variable list, that can be a
    ;; single symbol, list, or dotted list
    (define (make-proper-list maybe-dotted-list)
      (cond ((null? maybe-dotted-list) '())
        ((pair? maybe-dotted-list)
         (cons (car maybe-dotted-list)
               (make-proper-list (cdr maybe-dotted-list))))
        (else
         (list maybe-dotted-list))))

    (let ((variables (make-proper-list variables)))
      `((psd-val ,(build-val-definition variables))
        (psd-set! ,(build-set-definition variables)))))


;;;
;;; A set! is instrumented by instrumenting the value.
;;;

      (define (instrument-set! expr)
    (let ((var (pexp->sexp (psd-cadr expr)))
          (val (psd-caddr expr)))
      `(set! ,var ,(instrument-expr val))))

;;;
;;; Quote and quasiquote. We don't try to instrument anything
;;; that is inside a quasiquote.
;;;

      (define (instrument-quasiquote expr)
    `(quasiquote ,(pexp->sexp (psd-cadr expr))))

      (define (instrument-quote expr)
    `(quote ,(pexp->sexp (psd-cadr expr))))

;;;
;;; A body (expression sequece) is instrumented by instrumenting each
;;; of the expressions. If there are internal defines, they are turned
;;; into an equivalent letrec form and access procedures for them are
;;; also generated.
;;;

      (define (instrument-body body)

    ;; Return the leading definitions as a list of pexps
    (define (leading-definitions body)
      (let loop ((body body)
             (definitions '()))
        (cond ((psd-null? body)
           (reverse definitions))
          ((and (psd-pair? (psd-car body))
            (eq? 'define
                 (pexp->sexp (psd-caar body))))
           (loop (psd-cdr body)
             (cons (psd-car body)
                   definitions)))
          (else
           (reverse definitions)))))

    ;; Return the rest of the body as a pexp
    (define (trailing-exprs body)
      (let loop ((body body))
        (cond ((psd-null? body) body)
          ((and (psd-pair? (psd-car body))
            (eq? 'define
                 (pexp->sexp (psd-caar body))))
           (loop (psd-cdr body)))
          (else body))))

    ;; Given a define form, return a corresponding binding for a letrec
    (define (build-letrec-binding definition variables)
      `(,(definition-name definition)
        ,(access-wrapper (list (build-definition-body definition)) variables)))


    ;; If there are no internal definitions, do not wrap a redundant letrec
    ;; around the body
    (let ((definitions (leading-definitions body)))
      (if (null? definitions)

          (psd-map instrument-expr body)

          ;; there were definitions, so we must wrap a letrec around the
          ;; expressions that make up the body
          (let ((variables (map definition-name definitions)))
        `((letrec ,(map (lambda (binding)
                  (build-letrec-binding binding variables))
                definitions)
            ,(access-wrapper
              (psd-map instrument-expr
                   (trailing-exprs body))
              variables)))))))


;;;
;;; Instrument (and ...)
;;;

      (define (instrument-and form)
    (cons 'and (psd-map instrument-expr (psd-cdr form))))

;;;
;;; Instrument (or ...)
;;;

      (define (instrument-or form)
    (cons 'or (psd-map instrument-expr (psd-cdr form))))

;;;
;;; Instrument (do ...)
;;; This is rather messy, because of the scoping rules of the do form.
;;; There is no convinient place to put the access procedures so that
;;; all variables would be visible at all times.
;;;
;;; The problem is that all the variables are visible at the update
;;; forms but not at the init forms. For this reason we have to wrap a
;;; let around every update form in order to get to the right values.
;;; The same applies to the test and result forms.
;;;

      (define (instrument-do form)

    ;; Instrument a do variable binding
    (define (instrument-do-binding binding variables)
      (let ((variable (pexp->sexp (psd-car binding)))
        (init (psd-cadr binding))
        (step
         (if (psd-null? (psd-cddr binding))
             (psd-car binding)
             (psd-caddr binding))))
        `(,variable ,(instrument-expr init)
            ,(access-wrapper (list (instrument-expr step))
                     variables))))


    (let ((bindings (psd-cadr form))
          (variables (let-variables (psd-cadr form)))
          (test-result (psd-caddr form))
          (body (psd-cdddr form)))

      `(do ,(psd-map (lambda (binding)
               (instrument-do-binding binding variables))
             bindings)
           ,(psd-map instrument-expr
             test-result)
         ,@(instrument-body body))))


;;;
;;; Instrument (begin ...)
;;;

      (define (instrument-begin form)
    (cons 'begin (instrument-body (psd-cdr form))))

;;;
;;; Instrument a let, let* or letrec binding list.
;;;

      (define (instrument-let-bindings bindings)
    (let loop ((bindings bindings)
           (result '()))
      (if (psd-null? bindings)
          (reverse result)
          (let ((var (psd-expr-contents (psd-caar bindings)))
            (expr (psd-cadar bindings)))
        (loop (psd-cdr bindings)
              (cons (list var
                  (instrument-expr expr))
                result))))))

;;;
;;; Return a list of variables being bound in a binding list.
;;;

      (define (let-variables bindings)
    (psd-map (lambda (binding)
           (psd-expr-contents (psd-car binding)))
         bindings))

;;;
;;; Instrument a let, let* or letrec form. We have to be aware of
;;; named let.
;;;

      (define (instrument-let form)
    (instrument-let-form form 'let))

      (define (instrument-let* form)
    (instrument-let-form form 'let*))

      (define (instrument-letrec form)
    (instrument-let-form form 'letrec))


      (define (instrument-let-form form keyword)
    (let ((bindings (if (psd-pair? (psd-cadr form))
                (psd-cadr form)
                (psd-caddr form)))
          (name (if (psd-pair? (psd-cadr form))
            '()
            (list (pexp->sexp (psd-cadr form)))))
          (body (if (psd-pair? (psd-cadr form))
            (psd-cddr form)
            (psd-cdddr form))))
      `(,keyword ,@name ,(instrument-let-bindings bindings)
             (let ,(build-val-set-definitions (let-variables bindings))
               ,@(instrument-body body)))))


;;;
;;; Instrument a lambda.
;;;

      (define (instrument-lambda form)
    (let ((variables (psd-cadr form))
          (body (psd-cddr form)))
      `(lambda ,(pexp->sexp variables)
         (let ,(build-val-set-definitions (psd-map pexp->sexp variables))
           ,@(instrument-body body)))))

;;;
;;; Return the name of the variable being defined in a definition.
;;;
      (define (definition-name definition)
    (let ((variable (psd-cadr definition)))
      (pexp->sexp
       (if (psd-pair? variable)
           (psd-car variable)
           variable))))

;;;
;;; Build an instrumented body that corresponds to the definition. We
;;; need to be aware of (define foo ...) and (define (foo ...) ...).
;;;
;;; For each procedure definition of the form
;;; (define (foo x) ...) we supply a procedure definition that will
;;; give the name of this and surrounding procedures.
;;;

      (define (build-definition-body form)
    (if (psd-pair? (psd-car (psd-cdr form)))

        ;; we have a (define (foo x) ...)
        (let* ((heading (psd-car (psd-cdr form)))
           (proc-name (psd-expr-contents (psd-car heading)))
           (arguments (psd-map psd-expr-contents (psd-cdr heading)))
           (body (psd-cdr (psd-cdr form))))
          `(let ((psd-context
              (lambda () (cons ',proc-name
                       (psd-context)))))
         (lambda ,arguments
           (let ,(build-val-set-definitions arguments)
             ,@(instrument-body body)))))

        ;; we have a (define foo ...)
        (let ((expr (psd-caddr form)))
          (instrument-expr expr))))

;;;
;;; Instrument a define.
;;;

      (define (instrument-define form)
    `(define ,(definition-name form) ,(build-definition-body form)))

;;;
;;; Instrument an if.
;;;

      (define (instrument-if form)
    (let ((condition (psd-car (psd-cdr form)))
          (then-branch (psd-car (psd-cdr (psd-cdr form))))
          (else-branch
           (if (psd-null? (psd-cdr (psd-cdr (psd-cdr form))))
           #f
           (psd-car (psd-cdr (psd-cdr (psd-cdr form)))))))
      (if else-branch
          `(if ,(instrument-expr condition)
           ,(instrument-expr then-branch)
           ,(instrument-expr else-branch))
          `(if ,(instrument-expr condition)
           ,(instrument-expr then-branch)))))

;;;
;;; Instrument a cond.
;;;

      (define (instrument-cond expr)

    (define (instrument-cond-clause clause)
      (cond

       ;; else clause
       ((and (psd-symbol? (psd-car clause))
         (eq? (pexp->sexp (psd-car clause))
              'else))
        `(else ,@(instrument-body (psd-cdr clause))))

       ;; clause with just the predicate part
       ((psd-null? (psd-cdr clause))
        `(,instrument-expr (psd-car clause)))

       ;; ordinary clause
       (else
        `(,(instrument-expr (psd-car clause)) ,@(instrument-body (psd-cdr clause))))))

    `(cond ,@(psd-map instrument-cond-clause (psd-cdr expr))))

;;;
;;; Instrument a case.
;;;

      (define (instrument-case expr)

    (define (instrument-case-clause clause)
      (cond

       ;; else clause
       ((and (psd-symbol? (psd-car clause))
         (eq? (pexp->sexp (psd-car clause))
              'else))
        `(else ,@(instrument-body (psd-cdr clause))))

       ;; ordinary clause
       (else
        `(,(pexp->sexp (psd-car clause)) ,@(instrument-body (psd-cdr clause))))))

    `(case ,(instrument-expr (psd-cadr expr))
       ,@(psd-map instrument-case-clause (psd-cddr expr))))

;;;
;;; Instrument a procedure call. In case the call would cause a run
;;; time error, all the necessary information for invoking the
;;; debugger command loop is passed to psd-apply also. The value #f in
;;; the continuation position indicates to the command loop that the
;;; program can only be continued with a user supplied return value
;;; for the call.
;;;

      (define (instrument-call expr)

    (define file-name car)        ; for accessing the position info
    (define line-number cadr)

    ;; (lambda x x) is used instead of list just in case someone
    ;; wants to redefine list
    `(psd-apply ((lambda x x) ,@(psd-map instrument-expr expr))
            psd-val psd-set! psd-context
            ',(pexp->sexp expr)
            ,(file-name (psd-expr-start expr))
            ,(line-number (psd-expr-start expr))
            ,(line-number (psd-expr-end expr))
            #f))


;;;
;;; Each instrumented file contains procedures that map the names of
;;; the top level symbols to the corresponding variables.
;;;

      (define (build-global-accessors file-name)

    (define (build-accessor expr branches)
      (if (or (not (pair? expr))
          (not (eq? 'define (car expr))))

          ;; this was not a definition
          branches

          ;; now we have to distinguis between (define foo ..) and
          ;; (define (foo ...) ...)
          (let ((var (if (pair? (cadr expr))
                 (caadr expr)
                 (cadr expr))))
        (cons `((,var) ((lambda x x) ,var))
              branches))))


    (let ((port (open-input-file file-name)))
      (let loop ((expr (pexp->sexp (psd-read port file-name)))
             (case-branches '()))
        (if (eof-object? expr)

        `(set! psd-global-symbol-accessors
               (cons (lambda (psd-temp)
                   (case psd-temp
                 ,@case-branches
                 (else #f)))
                 psd-global-symbol-accessors))

        (loop (pexp->sexp (psd-read port file-name))
              (build-accessor expr case-branches))))))


      (define (build-global-setters file-name)

    (define (build-setter expr branches)
      (if (or (not (pair? expr))
          (not (eq? 'define (car expr))))

          ;; this was not a definition
          branches

          ;; now we have to distinguis between (define foo ..) and
          ;; (define (foo ...) ...)
          (let ((var (if (pair? (cadr expr))
                 (caadr expr)
                 (cadr expr))))
        (cons `((,var) (set! ,var psd-temp2))
              branches))))


    (let ((port (open-input-file file-name)))
      (let loop ((expr (pexp->sexp (psd-read port file-name)))
             (case-branches '()))
        (if (eof-object? expr)

        `(set! psd-global-symbol-setters
               (cons (lambda (psd-temp psd-temp2)
                   (case psd-temp
                 ,@case-branches
                 (else #f)))
                 psd-global-symbol-setters))

        (loop (pexp->sexp (psd-read port file-name))
              (build-setter expr case-branches))))))




;;;
;;; Body of instrument-file
;;;

      (let* ((infile (open-input-file source-file))
         (outfile (open-output-file instrumented-file)))
    (set! *psd-source-line-number* 1)
    (set! *psd-source-char-position* 1)
    (let loop ((expr (psd-read infile source-file)))
      (if (eof-object? expr)
          (begin
        (write (build-global-accessors source-file)
               outfile)
        (newline outfile)
        (write (build-global-setters source-file)
               outfile)
        (newline outfile)
        (close-output-port outfile))
          (begin
        (write (instrument-expr expr)
               outfile)
        (newline outfile)
        (loop (psd-read infile source-file)))))))))